home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / !runtime / externcp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-18  |  4.9 KB  |  168 lines  |  [TEXT/R*ch]
  1. /* Structured output, compact format */
  2.  
  3. #include "debugger.h"
  4. #include "fail.h"
  5. #include "gc.h"
  6. #include "intext.h"
  7. #include "io.h"
  8. #include "memory.h"
  9. #include "mlvalues.h"
  10. #include "reverse.h"
  11.  
  12. static void output_number(chan, code, val, nbits)
  13.      struct channel * chan;
  14.      int code, nbits;
  15.      long val;
  16. {
  17.   int i;
  18.   putch(chan, code);
  19.   for (i = nbits - 8; i >= 0; i -= 8) putch(chan, val >> i);
  20. }
  21.  
  22. static byteoffset_t obj_counter;    /* Number of objects emitted so far */
  23. static unsigned long size_32;  /* Size in words of 32-bit block for struct. */
  24. static unsigned long size_64;  /* Size in words of 64-bit block for struct. */
  25.  
  26. static void emit_compact(chan, v)
  27.      struct channel * chan;
  28.      value v;
  29. {
  30.  tailcall:
  31.   if (Is_long(v)) {
  32.     long n = Long_val(v);
  33.     if (n >= 0 && n < 0x40) {
  34.       putch(chan, PREFIX_SMALL_INT + n);
  35.     } else if (n >= -(1 << 7) && n < (1 << 7)) {
  36.       output_number(chan, CODE_INT8, n, 8);
  37.     } else if (n >= -(1 << 15) && n < (1 << 15)) {
  38.       output_number(chan, CODE_INT16, n, 16);
  39. #ifdef SIXTYFOUR
  40.     } else if (n < -(1L << 31) || n >= (1L << 31)) {
  41.       output_number(chan, CODE_INT64, n, 64);
  42. #endif
  43.     } else
  44.       output_number(chan, CODE_INT32, n, 32);
  45.   } else {
  46.     header_t hd = Hd_val(v);
  47.     tag_t tag = Tag_hd(hd);
  48.     mlsize_t sz = Wosize_hd(hd);
  49.       asize_t h;
  50.     /* Atoms are treated specially for two reasons: they are not allocated
  51.        in the externed block, and they are automatically shared. */
  52.     if (sz == 0) {
  53.       if (tag < 16) {
  54.         putch(chan, PREFIX_SMALL_BLOCK + tag);
  55.       } else {
  56.         output_number(chan, CODE_BLOCK32, hd, 32);
  57.       }
  58.     } else {
  59.       /* Check if already seen */
  60.       if (2 * obj_counter >= extern_table_size) resize_extern_table();
  61.       h = Hash(v);
  62.       while (extern_table[h].obj != 0) {
  63.         if (extern_table[h].obj == v) {
  64.           byteoffset_t d = obj_counter - extern_table[h].ofs;
  65.           if (d < 0x100) {
  66.             output_number(chan, CODE_SHARED8, d, 8);
  67.           } else if (d < 0x10000) {
  68.             output_number(chan, CODE_SHARED16, d, 16);
  69.           } else {
  70.             output_number(chan, CODE_SHARED32, d, 32);
  71.           }
  72.           return;
  73.         }
  74.         h++;
  75.         if (h >= extern_table_size) h = 0;
  76.       }
  77.       /* Not seen yet. Record the object and output its contents. */
  78.       extern_table[h].obj = v;
  79.       extern_table[h].ofs = obj_counter;
  80.       obj_counter++;
  81.       switch(tag) {
  82.       case String_tag: {
  83.         mlsize_t len = string_length(v);
  84.         if (len < 0x20) {
  85.           putch(chan, PREFIX_SMALL_STRING + len);
  86.         } else if (len < 0x100) {
  87.           output_number(chan, CODE_STRING8, len, 8);
  88.         } else {
  89.           output_number(chan, CODE_STRING32, len, 32);
  90.         }
  91.         putblock(chan, String_val(v), len);
  92.         size_32 += 1 + (len + 4) / 4;
  93.         size_64 += 1 + (len + 8) / 8;
  94.         break;
  95.       }
  96.       case Double_tag: {
  97.         double buffer;
  98.         if (sizeof(double) != 8)
  99.           invalid_argument("output_compact_value: non-standard floats");
  100.         putch(chan, CODE_DOUBLE);
  101.         buffer = Double_val(v);
  102. #ifndef MOSML_BIG_ENDIAN
  103.         Reverse_double(&buffer);
  104. #endif
  105.         putblock(chan, (char *) &buffer, 8);
  106.         size_32 += 1 + sizeof(double) / 4;
  107.         size_64 += 1 + sizeof(double) / 8;
  108.         break;
  109.       }
  110.       case Abstract_tag:
  111.       case Final_tag:
  112.         invalid_argument("output_compact_value: abstract value");
  113.         break;
  114.       case Closure_tag:
  115.         invalid_argument("output_compact_value: functional value");
  116.         break;
  117.       default: {
  118.         mlsize_t i;
  119.         if (tag < 16 && sz < 8) {
  120.           putch(chan, PREFIX_SMALL_BLOCK + tag + (sz << 4));
  121.         } else {
  122.           output_number(chan, CODE_BLOCK32, hd, 32);
  123.         }
  124.         size_32 += 1 + sz;
  125.         size_64 += 1 + sz;
  126.         for (i = 0; i < sz - 1; i++) emit_compact(chan, Field(v, i));
  127.         v = Field(v, i);
  128.         goto tailcall;
  129.       }
  130.       }
  131.     }
  132.   }
  133. }
  134.  
  135. value extern_compact_val(chan, v) /* ML */
  136.      struct channel * chan;
  137.      value v;
  138. {
  139.   value start_loc, final_loc;
  140.   putword(chan, Compact_magic_number);
  141.   start_loc = pos_out(chan);
  142.   putword(chan, 0);
  143.   putword(chan, 0);
  144.   putword(chan, 0);
  145.   extern_table_size = INITIAL_EXTERN_TABLE_SIZE;
  146.   alloc_extern_table();
  147.   obj_counter = 0;
  148.   size_32 = 0;
  149.   size_64 = 0;
  150.   emit_compact(chan, v);
  151. #ifdef SIXTYFOUR
  152.   if (size_32 >= (1L << 32) || size_64 >= (1L << 32)) {
  153.     /* The object is so big its size cannot be written in the header.
  154.        Besides, some of the block sizes or string lengths or shared offsets
  155.        it contains may have overflowed the 32 bits used to write them. */
  156.     failwith("output_compact_value: object too big");
  157.   }
  158. #endif
  159.   final_loc = pos_out(chan);
  160.   seek_out(chan, start_loc);
  161.   putword(chan, obj_counter);
  162.   putword(chan, size_32);
  163.   putword(chan, size_64);
  164.   seek_out(chan, final_loc);
  165.   stat_free((char *) extern_table);
  166.   return Val_unit;
  167. }
  168.